home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / FROMUTS / XLISP1 / !XLisp / c / XLMATH < prev    next >
Text File  |  1990-02-23  |  11KB  |  533 lines
  1. /* xlmath - xlisp builtin arithmetic functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #ifdef MEGAMAX
  7. #include <fmath.h>
  8. overlay "math"
  9. #else
  10. #include <math.h>
  11. #endif
  12.  
  13. /*
  14.  * Lattice's math.h include declarations for fabs, so must come before
  15.  * xlisp.h
  16.  */
  17.  
  18. #include "xlisp.h"
  19.  
  20. /* external variables */
  21. extern NODE *true;
  22.  
  23. /* forward declarations */
  24. FORWARD NODE *unary();
  25. FORWARD NODE *binary();
  26. FORWARD NODE *predicate();
  27. FORWARD NODE *compare();
  28.  
  29. /* xadd - builtin function for addition */
  30. NODE *xadd(args)
  31.   NODE *args;
  32. {
  33.     return (binary(args,'+'));
  34. }
  35.  
  36. /* xsub - builtin function for subtraction */
  37. NODE *xsub(args)
  38.   NODE *args;
  39. {
  40.     return (binary(args,'-'));
  41. }
  42.  
  43. /* xmul - builtin function for multiplication */
  44. NODE *xmul(args)
  45.   NODE *args;
  46. {
  47.     return (binary(args,'*'));
  48. }
  49.  
  50. /* xdiv - builtin function for division */
  51. NODE *xdiv(args)
  52.   NODE *args;
  53. {
  54.     return (binary(args,'/'));
  55. }
  56.  
  57. /* xrem - builtin function for remainder */
  58. NODE *xrem(args)
  59.   NODE *args;
  60. {
  61.     return (binary(args,'%'));
  62. }
  63.  
  64. /* xmin - builtin function for minimum */
  65. NODE *xmin(args)
  66.   NODE *args;
  67. {
  68.     return (binary(args,'m'));
  69. }
  70.  
  71. /* xmax - builtin function for maximum */
  72. NODE *xmax(args)
  73.   NODE *args;
  74. {
  75.     return (binary(args,'M'));
  76. }
  77.  
  78. /* xexpt - built-in function 'expt' */
  79. NODE *xexpt(args)
  80.   NODE *args;
  81. {
  82.     return (binary(args,'E'));
  83. }
  84.  
  85. /* xbitand - builtin function for bitwise and */
  86. NODE *xbitand(args)
  87.   NODE *args;
  88. {
  89.     return (binary(args,'&'));
  90. }
  91.  
  92. /* xbitior - builtin function for bitwise inclusive or */
  93. NODE *xbitior(args)
  94.   NODE *args;
  95. {
  96.     return (binary(args,'|'));
  97. }
  98.  
  99. /* xbitxor - builtin function for bitwise exclusive or */
  100. NODE *xbitxor(args)
  101.   NODE *args;
  102. {
  103.     return (binary(args,'~'));
  104. }
  105.  
  106. /* binary - handle binary operations */
  107. LOCAL NODE *binary(args,fcn)
  108.   NODE *args; int fcn;
  109. {
  110.     FIXNUM ival,iarg;
  111.     FLONUM fval,farg;
  112.     NODE *arg;
  113.     int imode;
  114.  
  115.     /* get the first argument */
  116.     arg = xlarg(&args);
  117.  
  118.     /* set the type of the first argument */
  119.     if (fixp(arg)) {
  120.     ival = getfixnum(arg);
  121.     imode = TRUE;
  122.     }
  123.     else if (floatp(arg)) {
  124.     fval = getflonum(arg);
  125.     imode = FALSE;
  126.     }
  127.     else
  128.     xlerror("bad argument type",arg);
  129.  
  130.     /* treat '-' with a single argument as a special case */
  131.     if (fcn == '-' && args == NIL)
  132.     if (imode)
  133.         ival = -ival;
  134.     else
  135.         fval = -fval;
  136.  
  137.     /* handle each remaining argument */
  138.     while (args) {
  139.  
  140.     /* get the next argument */
  141.     arg = xlarg(&args);
  142.  
  143.     /* check its type */
  144.     if (fixp(arg))
  145.         if (imode) iarg = getfixnum(arg);
  146.         else farg = (FLONUM)getfixnum(arg);
  147.     else if (floatp(arg))
  148.         if (imode) { fval = (FLONUM)ival; farg = getflonum(arg); imode = FALSE; }
  149.         else farg = getflonum(arg);
  150.     else
  151.         xlerror("bad argument type",arg);
  152.  
  153.     /* accumulate the result value */
  154.     if (imode)
  155.         switch (fcn) {
  156.         case '+':    ival += iarg; break;
  157.         case '-':    ival -= iarg; break;
  158.         case '*':    ival *= iarg; break;
  159.         case '/':    checkizero(iarg); ival /= iarg; break;
  160.         case '%':    checkizero(iarg); ival %= iarg; break;
  161.         case 'M':    if (iarg > ival) ival = iarg; break;
  162.         case 'm':    if (iarg < ival) ival = iarg; break;
  163.         case '&':    ival &= iarg; break;
  164.         case '|':    ival |= iarg; break;
  165.         case '^':   ival ^= iarg; break;
  166.         default:    badiop();
  167.         }
  168.     else
  169.         switch (fcn) {
  170.         case '+':    fval += farg; break;
  171.         case '-':    fval -= farg; break;
  172.         case '*':    fval *= farg; break;
  173.         case '/':    checkfzero(farg); fval /= farg; break;
  174.         case 'M':    if (farg > fval) fval = farg; break;
  175.         case 'm':    if (farg < fval) fval = farg; break;
  176.         case 'E':    fval = pow(fval,farg); break;
  177.         default:    badfop();
  178.         }
  179.     }
  180.  
  181.     /* return the result */
  182.     return (imode ? cvfixnum(ival) : cvflonum(fval));
  183. }
  184.  
  185. /* checkizero - check for integer division by zero */
  186. checkizero(iarg)
  187.   FIXNUM iarg;
  188. {
  189.     if (iarg == 0)
  190.     xlfail("division by zero");
  191. }
  192.  
  193. /* checkfzero - check for floating point division by zero */
  194. checkfzero(farg)
  195.   FLONUM farg;
  196. {
  197.     if (farg == 0.0)
  198.     xlfail("division by zero");
  199. }
  200.  
  201. /* checkfneg - check for square root of a negative number */
  202. checkfneg(farg)
  203.   FLONUM farg;
  204. {
  205.     if (farg < 0.0)
  206.     xlfail("square root of a negative number");
  207. }
  208.  
  209. /* xbitnot - bitwise not */
  210. NODE *xbitnot(args)
  211.   NODE *args;
  212. {
  213.     return (unary(args,'~'));
  214. }
  215.  
  216. /* xabs - builtin function for absolute value */
  217. NODE *xabs(args)
  218.   NODE *args;
  219. {
  220.     return (unary(args,'A'));
  221. }
  222.  
  223. /* xadd1 - builtin function for adding one */
  224. NODE *xadd1(args)
  225.   NODE *args;
  226. {
  227.     return (unary(args,'+'));
  228. }
  229.  
  230. /* xsub1 - builtin function for subtracting one */
  231. NODE *xsub1(args)
  232.   NODE *args;
  233. {
  234.     return (unary(args,'-'));
  235. }
  236.  
  237. /* xsin - built-in function 'sin' */
  238. NODE *xsin(args)
  239.   NODE *args;
  240. {
  241.     return (unary(args,'S'));
  242. }
  243.  
  244. /* xcos - built-in function 'cos' */
  245. NODE *xcos(args)
  246.   NODE *args;
  247. {
  248.     return (unary(args,'C'));
  249. }
  250.  
  251. /* xtan - built-in function 'tan' */
  252. NODE *xtan(args)
  253.   NODE *args;
  254. {
  255.     return (unary(args,'T'));
  256. }
  257.  
  258. /* xexp - built-in function 'exp' */
  259. NODE *xexp(args)
  260.   NODE *args;
  261. {
  262.     return (unary(args,'E'));
  263. }
  264.  
  265. /* xsqrt - built-in function 'sqrt' */
  266. NODE *xsqrt(args)
  267.   NODE *args;
  268. {
  269.     return (unary(args,'R'));
  270. }
  271.  
  272. /* xfix - built-in function 'fix' */
  273. NODE *xfix(args)
  274.   NODE *args;
  275. {
  276.     return (unary(args,'I'));
  277. }
  278.  
  279. /* xfloat - built-in function 'float' */
  280. NODE *xfloat(args)
  281.   NODE *args;
  282. {
  283.     return (unary(args,'F'));
  284. }
  285.  
  286. /* xrand - built-in function 'random' */
  287. NODE *xrand(args)
  288.   NODE *args;
  289. {
  290.     return (unary(args,'R'));
  291. }
  292.  
  293. /* unary - handle unary operations */
  294. LOCAL NODE *unary(args,fcn)
  295.   NODE *args; int fcn;
  296. {
  297.     FLONUM fval;
  298.     FIXNUM ival;
  299.     NODE *arg;
  300.  
  301.     /* get the argument */
  302.     arg = xlarg(&args);
  303.     xllastarg(args);
  304.  
  305.     /* check its type */
  306.     if (fixp(arg)) {
  307.     ival = getfixnum(arg);
  308.     switch (fcn) {
  309.     case '~':    ival = ~ival; break;
  310.     case 'A':    ival = abs(ival); break;
  311.     case '+':    ival++; break;
  312.     case '-':    ival--; break;
  313.     case 'I':    break;
  314.     case 'F':    return (cvflonum((FLONUM)ival));
  315.     case 'R':    ival = (FIXNUM)osrand((int)ival); break;
  316.     default:    badiop();
  317.     }
  318.     return (cvfixnum(ival));
  319.     }
  320.     else if (floatp(arg)) {
  321.     fval = getflonum(arg);
  322.     switch (fcn) {
  323.     case 'A':    fval = fabs(fval); break;
  324.     case '+':    fval += 1.0; break;
  325.     case '-':    fval -= 1.0; break;
  326.     case 'S':    fval = sin(fval); break;
  327.     case 'C':    fval = cos(fval); break;
  328.     case 'T':    fval = tan(fval); break;
  329.     case 'E':    fval = exp(fval); break;
  330.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  331.     case 'I':    return (cvfixnum((FIXNUM)fval));
  332.     case 'F':    break;
  333.     default:    badfop();
  334.     }
  335.     return (cvflonum(fval));
  336.     }
  337.     else
  338.     xlerror("bad argument type",arg);
  339.     /*NOTREACHED*/
  340. }
  341.  
  342. /* xminusp - is this number negative? */
  343. NODE *xminusp(args)
  344.   NODE *args;
  345. {
  346.     return (predicate(args,'-'));
  347. }
  348.  
  349. /* xzerop - is this number zero? */
  350. NODE *xzerop(args)
  351.   NODE *args;
  352. {
  353.     return (predicate(args,'Z'));
  354. }
  355.  
  356. /* xplusp - is this number positive? */
  357. NODE *xplusp(args)
  358.   NODE *args;
  359. {
  360.     return (predicate(args,'+'));
  361. }
  362.  
  363. /* xevenp - is this number even? */
  364. NODE *xevenp(args)
  365.   NODE *args;
  366. {
  367.     return (predicate(args,'E'));
  368. }
  369.  
  370. /* xoddp - is this number odd? */
  371. NODE *xoddp(args)
  372.   NODE *args;
  373. {
  374.     return (predicate(args,'O'));
  375. }
  376.  
  377. /* predicate - handle a predicate function */
  378. LOCAL NODE *predicate(args,fcn)
  379.   NODE *args; int fcn;
  380. {
  381.     FLONUM fval;
  382.     FIXNUM ival;
  383.     NODE *arg;
  384.  
  385.     /* get the argument */
  386.     arg = xlarg(&args);
  387.     xllastarg(args);
  388.  
  389.     /* check the argument type */
  390.     if (fixp(arg)) {
  391.     ival = getfixnum(arg);
  392.     switch (fcn) {
  393.     case '-':    ival = (ival < 0); break;
  394.     case 'Z':    ival = (ival == 0); break;
  395.     case '+':    ival = (ival > 0); break;
  396.     case 'E':    ival = ((ival & 1) == 0); break;
  397.     case 'O':    ival = ((ival & 1) != 0); break;
  398.     default:    badiop();
  399.     }
  400.     }
  401.     else if (floatp(arg)) {
  402.     fval = getflonum(arg);
  403.     switch (fcn) {
  404.     case '-':    ival = (fval < 0); break;
  405.     case 'Z':    ival = (fval == 0); break;
  406.     case '+':    ival = (fval > 0); break;
  407.     default:    badfop();
  408.     }
  409.     }
  410.     else
  411.     xlerror("bad argument type",arg);
  412.  
  413.     /* return the result value */
  414.     return (ival ? true : NIL);
  415. }
  416.  
  417. /* xlss - builtin function for < */
  418. NODE *xlss(args)
  419.   NODE *args;
  420. {
  421.     return (compare(args,'<'));
  422. }
  423.  
  424. /* xleq - builtin function for <= */
  425. NODE *xleq(args)
  426.   NODE *args;
  427. {
  428.     return (compare(args,'L'));
  429. }
  430.  
  431. /* equ - builtin function for = */
  432. NODE *xequ(args)
  433.   NODE *args;
  434. {
  435.     return (compare(args,'='));
  436. }
  437.  
  438. /* xneq - builtin function for /= */
  439. NODE *xneq(args)
  440.   NODE *args;
  441. {
  442.     return (compare(args,'#'));
  443. }
  444.  
  445. /* xgeq - builtin function for >= */
  446. NODE *xgeq(args)
  447.   NODE *args;
  448. {
  449.     return (compare(args,'G'));
  450. }
  451.  
  452. /* xgtr - builtin function for > */
  453. NODE *xgtr(args)
  454.   NODE *args;
  455. {
  456.     return (compare(args,'>'));
  457. }
  458.  
  459. /* compare - common compare function */
  460. LOCAL NODE *compare(args,fcn)
  461.   NODE *args; int fcn;
  462. {
  463.     NODE *arg1,*arg2;
  464.     FIXNUM icmp;
  465.     FLONUM fcmp;
  466.     int imode;
  467.  
  468.     /* get the two arguments */
  469.     arg1 = xlarg(&args);
  470.     arg2 = xlarg(&args);
  471.     xllastarg(args);
  472.  
  473.     /* do the compare */
  474.     if (stringp(arg1) && stringp(arg2)) {
  475.     icmp = strcmp(getstring(arg1),getstring(arg2));
  476.     imode = TRUE;
  477.     }
  478.     else if (fixp(arg1) && fixp(arg2)) {
  479.     icmp = getfixnum(arg1) - getfixnum(arg2);
  480.     imode = TRUE;
  481.     }
  482.     else if (floatp(arg1) && floatp(arg2)) {
  483.     fcmp = getflonum(arg1) - getflonum(arg2);
  484.     imode = FALSE;
  485.     }
  486.     else if (fixp(arg1) && floatp(arg2)) {
  487.     fcmp = (FLONUM)getfixnum(arg1) - getflonum(arg2);
  488.     imode = FALSE;
  489.     }
  490.     else if (floatp(arg1) && fixp(arg2)) {
  491.     fcmp = getflonum(arg1) - (FLONUM)getfixnum(arg2);
  492.     imode = FALSE;
  493.     }
  494.     else
  495.     xlfail("expecting strings, integers or floats");
  496.  
  497.     /* compute result of the compare */
  498.     if (imode)
  499.     switch (fcn) {
  500.     case '<':    icmp = (icmp < 0); break;
  501.     case 'L':    icmp = (icmp <= 0); break;
  502.     case '=':    icmp = (icmp == 0); break;
  503.     case '#':    icmp = (icmp != 0); break;
  504.     case 'G':    icmp = (icmp >= 0); break;
  505.     case '>':    icmp = (icmp > 0); break;
  506.     }
  507.     else
  508.     switch (fcn) {
  509.     case '<':    icmp = (fcmp < 0.0); break;
  510.     case 'L':    icmp = (fcmp <= 0.0); break;
  511.     case '=':    icmp = (fcmp == 0.0); break;
  512.     case '#':    icmp = (fcmp != 0.0); break;
  513.     case 'G':    icmp = (fcmp >= 0.0); break;
  514.     case '>':    icmp = (fcmp > 0.0); break;
  515.     }
  516.  
  517.     /* return the result */
  518.     return (icmp ? true : NIL);
  519. }
  520.  
  521. /* badiop - bad integer operation */
  522. LOCAL badiop()
  523. {
  524.     xlfail("bad integer operation");
  525. }
  526.  
  527. /* badfop - bad floating point operation */
  528. LOCAL badfop()
  529. {
  530.     xlfail("bad floating point operation");
  531. }
  532.  
  533.